home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / clx_tar.z / clx_tar / clx / kcl-patches.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-04-28  |  10.3 KB  |  286 lines
  1.  
  2. (in-package 'compiler)
  3.  
  4. #+akcl
  5. (eval-when (compile load eval)
  6. (when (<= system::*akcl-version* 609)
  7.   (pushnew :pre_akcl_610 *features*))
  8. )
  9.  
  10. #+pre_akcl_610
  11. (progn
  12.  
  13. ;(in-package 'system)
  14.  
  15. (proclaim '(optimize (safety 2) (space 3)))
  16.  
  17. ;[need this for clx/trace]
  18. ;added the call to best-array-element-type
  19. (defun make-sequence (type size &key (initial-element nil iesp)
  20.                                 &aux element-type sequence)
  21.   (setq element-type
  22.         (cond ((eq type 'list)
  23.                (return-from make-sequence
  24.                 (if iesp
  25.                     (make-list size :initial-element initial-element)
  26.                     (make-list size))))
  27.               ((or (eq type 'simple-string) (eq type 'string)) 'string-char)
  28.               ((or (eq type 'simple-bit-vector) (eq type 'bit-vector)) 'bit)
  29.               ((or (eq type 'simple-vector) (eq type 'vector)) t)
  30.               (t
  31.                (setq type (si::normalize-type type))
  32.                (when (eq (car type) 'list)
  33.                      (return-from make-sequence
  34.                       (if iesp
  35.                           (make-list size :initial-element initial-element)
  36.                           (make-list size))))
  37.                (unless (or (eq (car type) 'array)
  38.                            (eq (car type) 'simple-array))
  39.                        (error "~S is not a sequence type." type))
  40.                (or (cadr type) t))))
  41.   (setq element-type (si::best-array-element-type element-type))
  42.   (setq sequence (si::make-vector element-type size nil nil nil nil nil))
  43.   (when iesp
  44.         (do ((i 0 (1+ i))
  45.              (size size))
  46.             ((>= i size))
  47.           (declare (fixnum i size))
  48.           (setf (elt sequence i) initial-element)))
  49.   sequence)
  50.  
  51. ;The original version (in c/predicate.c) ignores the possibility that 
  52. ;arrays and vectors can have non-T element types.
  53. (defun si:contains-sharp-comma (x)
  54.   (typecase x
  55.     (complex (or (si:contains-sharp-comma (realpart x))
  56.          (si:contains-sharp-comma (imagpart x))))
  57.     (vector  (and (eq 't (array-element-type x))
  58.           (some #'si:contains-sharp-comma x)))
  59.     (cons    (or (eq 'si:|#,| (car x))
  60.          (si:contains-sharp-comma (car x))
  61.          (si:contains-sharp-comma (cdr x))))
  62.     (array   (and (eq 't (array-element-type x))
  63.           (let* ((rank (array-rank x))
  64.              (dimensions (make-list rank)))
  65.             (dotimes (i rank)
  66.               (setf (nth i dimensions) (array-dimension x i)))
  67.             (unless (member 0 dimensions)
  68.               (do ((cursor (make-list rank :initial-element 0)))
  69.               (nil)
  70.             (declare (:dynamic-extent cursor))
  71.             (when (si:contains-sharp-comma (apply #'aref x cursor))
  72.               (return t))
  73.             (when (si::increment-cursor cursor dimensions)
  74.               (return nil)))))))
  75.     (t (si:structurep x))))
  76.           
  77.  
  78. ;(in-package 'compiler)
  79.  
  80. ;[without this, xlib:create-window won't work]
  81. ;added inline-integer here.
  82. (defun get-inline-loc (ii args &aux (fun (car (cdddr ii))) locs)
  83.   ;;; Those functions that use GET-INLINE-LOC must rebind the variable *VS*.
  84.  (setq locs (inline-args args (car ii) fun))
  85.   (when (and (stringp fun) (char= (char (the string fun) 0) #\@))
  86.     (let ((i 1) (saves nil))
  87.          (declare (fixnum i))
  88.       (do ((char (char (the string fun) i)
  89.                  (char (the string fun) i)))
  90.           ((char= char #\;) (incf i))
  91.           (declare (character char))
  92.           (push (the fixnum (- (char-code char) #.(char-code #\0))) saves)
  93.           (incf i))
  94.       (do ((l locs (cdr l))
  95.            (n 0 (1+ n))
  96.            (locs1 nil))
  97.           ((endp l) (setq locs (reverse locs1)))
  98.           (declare (fixnum n) (object l))
  99.           (if (member n saves)
  100.               (let* ((loc1 (car l)) (loc loc1) (coersion nil))
  101.                     (declare (object loc loc1))
  102.                 (when (and (consp loc1)
  103.                            (member (car loc1)
  104.                                    '(FIXNUM-LOC integer-loc CHARACTER-LOC
  105.                                      LONG-FLOAT-LOC SHORT-FLOAT-LOC)))
  106.                       (setq coersion (car loc1))
  107.                       (setq loc (cadr loc1))  ; remove coersion
  108.                       )
  109.                 (cond
  110.                  ((and (consp loc)
  111.                (or
  112.              (member (car loc) 
  113.                                     '(INLINE INLINE-COND))
  114.              (and      (member (car loc)
  115.                      '(
  116.                        INLINE-FIXNUM inline-integer
  117.                        INLINE-CHARACTER INLINE-LONG-FLOAT
  118.                        INLINE-SHORT-FLOAT))
  119.                  (or (flag-p (cadr loc) allocates-new-storage)
  120.                      (flag-p (cadr loc) side-effect-p))
  121.                                 )))
  122.                   (wt-nl "{")
  123.                   (inc-inline-blocks)
  124.                   (let ((cvar (next-cvar)))
  125.                     (push (list 'CVAR cvar) locs1)
  126.                     (case coersion
  127.                      ((nil) (wt "object V" cvar "= ") (wt-loc loc1))
  128.                      (FIXNUM-LOC (wt "int V" cvar "= ") (wt-fixnum-loc loc))
  129.              (integer-loc (wt "GEN V" cvar "= ") (wt-integer-loc loc
  130.                                      'get-inline-locs))
  131.                      (CHARACTER-LOC
  132.                       (wt "unsigned char V" cvar "= ") (wt-character-loc loc))
  133.                      (LONG-FLOAT-LOC
  134.                       (wt "double V" cvar "= ") (wt-long-float-loc loc))
  135.                      (SHORT-FLOAT-LOC
  136.                       (wt "float V" cvar "= ") (wt-short-float-loc loc))
  137.                      (t (baboon))))
  138.                   (wt ";")
  139.                   )
  140.                  (t (push loc1 locs1))))
  141.               (push (car l) locs1)))))
  142.   (list (inline-type (cadr ii))
  143.         (caddr ii)
  144.         fun
  145.         locs)
  146.   )
  147.  
  148. ;added inline-integer
  149. (defun unwind-exit (loc &optional (jump-p nil) fname
  150.                         &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0) type.wt)
  151.   (declare (fixnum bds-bind))
  152.   (and *record-call-info* (record-call-info loc fname))
  153.   (when (and (eq loc 'fun-val)
  154.              (not (eq *value-to-go* 'return))
  155.              (not (eq *value-to-go* 'top)))
  156.         (wt-nl) (reset-top))
  157.   (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
  158.          (set-jump-true loc (cadr *value-to-go*))
  159.          (when (eq loc t) (return-from unwind-exit)))
  160.         ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
  161.          (set-jump-false loc (cadr *value-to-go*))
  162.          (when (null loc) (return-from unwind-exit))))
  163.   (dolist* (ue *unwind-exit* (baboon))
  164.    (cond
  165.     ((consp ue)
  166.      (cond ((eq ue *exit*)
  167.         (cond ((and (consp *value-to-go*)
  168.             (or (eq (car *value-to-go*) 'jump-true)
  169.                 (eq (car *value-to-go*) 'jump-false)))
  170.            (unwind-bds bds-cvar bds-bind))
  171.           (t
  172.            (if (or bds-cvar   (plusp bds-bind))
  173.                           ;;; Save the value if LOC may possibly refer
  174.                           ;;; to special binding.
  175.                (if (and (consp loc)
  176.                 (or (and (eq (car loc) 'var)
  177.                      (member (var-kind (cadr loc))
  178.                          '(SPECIAL GLOBAL)))
  179.                     (member (car loc)
  180.                         '(SIMPLE-CALL
  181.                           INLINE
  182.                           INLINE-COND INLINE-FIXNUM
  183.                           INLINE-CHARACTER
  184.                           INLINE-INTEGER
  185.                           INLINE-LONG-FLOAT
  186.                           INLINE-SHORT-FLOAT))))
  187.                (cond ((and (consp *value-to-go*)
  188.                        (eq (car *value-to-go*) 'vs))
  189.                   (set-loc loc)
  190.                   (unwind-bds bds-cvar bds-bind))
  191.                  (t (let
  192.                     ((temp (list 'cvar (cs-push))))
  193.                       (let ((*value-to-go* temp))
  194.                     (set-loc loc))
  195.                       (unwind-bds bds-cvar bds-bind)
  196.                       (set-loc temp))))
  197.              (progn (unwind-bds bds-cvar bds-bind)
  198.                 (set-loc loc)))
  199.              (set-loc loc))))
  200.  
  201.         (when jump-p
  202.           (when (consp *inline-blocks*) (wt-nl "restore_avma; "))
  203.           (wt-nl) (wt-go *exit*))
  204.         (return))
  205.        (t (setq jump-p t))))
  206.     ((numberp ue) (setq bds-cvar ue bds-bind 0))
  207.     ((eq ue 'bds-bind) (incf bds-bind))
  208.     ((eq ue 'return)
  209.      (when (eq *exit* 'return)
  210.               ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
  211.        (set-loc loc)
  212.        (unwind-bds bds-cvar bds-bind)
  213.        (wt-nl "return;")
  214.        (return))
  215.         ;;; Never reached
  216.      )
  217.     ((eq ue 'frame)
  218.      (when (and (consp loc)
  219.         (member (car loc)
  220.             '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM inline-integer
  221.                       INLINE-CHARACTER INLINE-LONG-FLOAT
  222.                       INLINE-SHORT-FLOAT)))
  223.        (cond ((and (consp *value-to-go*)
  224.            (eq (car *value-to-go*) 'vs))
  225.           (set-loc loc)
  226.           (setq loc *value-to-go*))
  227.          (t (let ((*value-to-go* (if *c-gc* (list 'cvar (cs-push))
  228.                        (list 'vs (vs-push)))))
  229.           (set-loc loc)
  230.           (setq loc *value-to-go*)))))
  231.      (wt-nl "frs_pop();"))
  232.     ((eq ue 'tail-recursion-mark))
  233.     ((eq ue 'jump) (setq jump-p t))
  234.     ((setq type.wt
  235.        (assoc ue
  236.           '((return-fixnum fixnum .  wt-fixnum-loc)
  237.             (return-character character . wt-character-loc)
  238.             (return-short-float short-float . wt-short-float-loc)
  239.             (return-long-float long-float . wt-long-float-loc)
  240.             (return-object t . wt-loc))))
  241.      (let ((cvar (next-cvar)))
  242.        (or (eq *exit* (car type.wt)) (wfs-error))
  243.        (setq type.wt (cdr type.wt))
  244.        (wt-nl "{" (rep-type (car type.wt)) "V" cvar " = ")
  245.        (funcall (cdr type.wt) loc)  (wt ";")
  246.        (unwind-bds bds-cvar bds-bind)
  247.        (wt-nl "VMR" *reservation-cmacro* "(V" cvar")}")
  248.        (return)))
  249.         
  250.     (t (baboon))
  251.        ;;; Never reached
  252.     ))
  253.   )
  254.  
  255. ;added inline-integer
  256. (defun set-loc (loc &aux fd)
  257.   (cond ((eq *value-to-go* 'return) (set-return loc))
  258.         ((eq *value-to-go* 'trash)
  259.          (cond ((and (consp loc)
  260.                      (member (car loc)
  261.                              '(INLINE INLINE-COND INLINE-FIXNUM inline-integer
  262.                                INLINE-CHARACTER INLINE-LONG-FLOAT
  263.                                INLINE-SHORT-FLOAT))
  264.                      (cadr loc))
  265.                 (wt-nl "(void)(") (wt-inline t (caddr loc) (cadddr loc))
  266.                 (wt ");"))
  267.                ((and (consp loc) (eq (car loc) 'SIMPLE-CALL))
  268.                 (wt-nl "(void)" loc ";"))))
  269.         ((eq *value-to-go* 'top)
  270.          (unless (eq loc 'fun-val) (set-top loc)))
  271.         ((eq *value-to-go* 'return-fixnum) (set-return-fixnum loc))
  272.         ((eq *value-to-go* 'return-character) (set-return-character loc))
  273.         ((eq *value-to-go* 'return-long-float) (set-return-long-float loc))
  274.         ((eq *value-to-go* 'return-short-float) (set-return-short-float loc))
  275.         ((or (not (consp *value-to-go*))
  276.              (not (symbolp (car *value-to-go*))))
  277.          (baboon))
  278.         ((setq fd (get (car *value-to-go*) 'set-loc))
  279.          (apply fd loc (cdr *value-to-go*)))
  280.         ((setq fd (get (car *value-to-go*) 'wt-loc))
  281.          (wt-nl) (apply fd (cdr *value-to-go*)) (wt "= " loc ";"))
  282.         (t (baboon)))
  283.   )
  284.  
  285. )
  286.